home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / Foxpro 2.6 {Windows} / APPPROC.PR_ / APPPROC.bin
Text File  |  1994-03-10  |  15KB  |  559 lines
  1. *!*****************************************************************
  2. *!
  3. *!      Procedure: FORCEEXT
  4. *!
  5. *!*****************************************************************
  6. FUNCTION forceext
  7. * Force the extension of "filname" to be whatever ext is.
  8. PARAMETERS filname,ext
  9. PRIVATE ALL
  10. IF SUBSTR(m.ext,1,1) = "."
  11.    m.ext = SUBSTR(m.ext,2,3)
  12. ENDIF
  13.  
  14. m.pname = justpath(m.filname)
  15. m.filname = justfname(UPPER(ALLTRIM(m.filname)))
  16. IF AT('.',m.filname) > 0
  17.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext
  18. ELSE
  19.    m.filname = m.filname + '.' + m.ext
  20. ENDIF
  21. RETURN addbs(m.pname) + m.filname
  22. *!*****************************************************************
  23. *!
  24. *!      Procedure: DEFAULTEXT
  25. *!
  26. *!*****************************************************************
  27. FUNCTION defaultext
  28. * Force the extension of "filname" to be whatever ext is, but only
  29. * if filname doesn't already have an extension.
  30. PARAMETERS filname,ext
  31. PRIVATE ALL
  32. IF EMPTY(justext(m.filname))
  33.    IF SUBSTR(m.ext,1,1) = "."
  34.       m.ext = SUBSTR(m.ext,2,3)
  35.    ENDIF
  36.  
  37.    RETURN m.filname + '.' + m.ext
  38. ELSE 
  39.    RETURN filname
  40. ENDIF      
  41.  
  42. *!*****************************************************************
  43. *!
  44. *!      Procedure: JUSTFNAME
  45. *!
  46. *!*****************************************************************
  47. FUNCTION justfname
  48. * Return just the filename (i.e., no path) from "filname"
  49. PARAMETERS filname
  50. PRIVATE ALL
  51. IF RAT('\',m.filname) > 0
  52.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  53. ENDIF
  54. IF RAT(':',m.filname) > 0
  55.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  56. ENDIF
  57. RETURN ALLTRIM(UPPER(m.filname))
  58.  
  59. *!*****************************************************************
  60. *!
  61. *!      Procedure: JUSTSTEM
  62. *!
  63. *!*****************************************************************
  64. FUNCTION juststem
  65. * Return just the stem name from "filname"
  66. PARAMETERS filname
  67. PRIVATE ALL
  68. IF RAT('\',m.filname) > 0
  69.    m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255)
  70. ENDIF
  71. IF RAT(':',m.filname) > 0
  72.    m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255)
  73. ENDIF
  74. IF AT('.',m.filname) > 0
  75.    m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1)
  76. ENDIF
  77. RETURN ALLTRIM(UPPER(m.filname))
  78.  
  79. *!*****************************************************************
  80. *!
  81. *!      Procedure: JUSTEXT
  82. *!
  83. *!*****************************************************************
  84. FUNCTION justext
  85. * Return just the extension from "filname"
  86. PARAMETERS filname
  87. PRIVATE ALL
  88. filname = JustFname(m.filname)   && prevents problems with ..\ paths
  89. m.ext = ""
  90. IF AT('.',m.filname) > 0
  91.    m.ext = SUBSTR(m.filname,AT('.',m.filname)+1,3)
  92. ENDIF
  93. RETURN UPPER(m.ext)
  94.  
  95.  
  96. *!*****************************************************************
  97. *!
  98. *!      Procedure: JUSTPATH
  99. *!
  100. *!*****************************************************************
  101. FUNCTION justpath
  102. * Return just the path name from "filname"
  103. PARAMETERS m.filname
  104. PRIVATE ALL
  105. m.filname = ALLTRIM(UPPER(m.filname))
  106. m.pathsep = IIF(_MAC,":", "\")
  107. IF _MAC
  108.    m.found_it = .F.
  109.    m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname))
  110.    IF m.maxchar > 0
  111.       m.filname = SUBSTR(m.filname,1,m.maxchar)
  112.       IF RIGHT(m.filname,1) $ ":\" AND LEN(m.filname) > 1 ;
  113.             AND !(SUBSTR(m.filname,LEN(m.filname)-1,1)  $ ":\")
  114.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  115.       ENDIF
  116.       RETURN m.filname
  117.    ENDIF
  118. ELSE
  119.    IF m.pathsep $ filname
  120.       m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname))
  121.       IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ;
  122.             AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep
  123.          m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  124.       ENDIF
  125.       RETURN m.filname
  126.    ENDIF      
  127. ENDIF
  128. RETURN ''
  129.  
  130. *!*****************************************************************
  131. *!
  132. *!      Procedure: ADDBS
  133. *!
  134. *!*****************************************************************
  135. FUNCTION addbs
  136. * Add a backslash to a path name if there isn't already one there
  137. PARAMETER m.pathname
  138. PRIVATE ALL
  139. m.pathname = ALLTRIM(UPPER(m.pathname))
  140. IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname)
  141.    m.pathname = m.pathname + IIF(_MAC,':','\')
  142. ENDIF
  143. RETURN m.pathname
  144.  
  145. *!*****************************************************************
  146. *!
  147. *!      Procedure: CASCADE
  148. *!
  149. *!*****************************************************************
  150. PROCEDURE cascade
  151. PARAMETERS aliasname, mode
  152. * Recursive procedure to cascade deletes out of the aliasname file and
  153. * its children.  Aliasname is the alias of a database known to be open.
  154. * Delete any child records with a key of keyvalue, but only if the user
  155. * has selected the cascading delete option for the child database.
  156. PRIVATE i, aliasname, keyfield, keyvalue
  157. aliasname = makealias(juststem(UPPER(ALLTRIM(aliasname))))
  158.  
  159. * First, see which files are children of this one and cascade them
  160. FOR i = 1 TO m.numareas
  161.    IF makealias(Juststem(UPPER(ALLTRIM(dbflist[i,m.pdbfnum])))) == m.aliasname
  162.       * 'i' points at a child of 'aliasname'
  163.       * Did the user elect to cascade deletes into this file?  Are there
  164.       * any matching child records to delete?
  165.       IF dbflist[i,m.cascadenum] = 'Y' and !EOF(dbflist[i,m.cstemnum])
  166.          * Select the child database
  167.          SELECT (dbflist[i,m.cstemnum])
  168.          
  169.          * We will already be positioned on the key value because of the
  170.          * relations that have been set.
  171.          keyfield = dbflist[i,m.cfldnum]
  172.          keyvalue = &keyfield
  173.          DO WHILE &keyfield == m.keyvalue and !EOF()
  174.             * But first delete any applicable children of this child database
  175.             DO cascade WITH dbflist[i,m.cstemnum], mode
  176.             
  177.             * Delete this child database record itself
  178.             IF mode = "DELETE"
  179.                DELETE
  180.                IF !EOF()
  181.                   SKIP
  182.                ENDIF
  183.             ENDIF
  184.          ENDDO
  185.       ENDIF
  186.    ENDIF
  187. ENDFOR
  188. SELECT (aliasname)
  189.  
  190. RETURN
  191.  
  192.  
  193. *!*****************************************************************
  194. *!
  195. *!      Procedure: INVERT
  196. *!
  197. *!*****************************************************************
  198. PROCEDURE invert
  199. * Invert (i.e., index on all fields) the "filname" database
  200.  
  201. PARAMETERS filname
  202. PRIVATE comp_stat, safe_stat, in_area, fstem, i
  203.  
  204. comp_stat = SET("COMPATIBLE")
  205. safe_stat = SET("SAFETY")
  206. SET COMPATIBLE TO FOXPLUS
  207. SET SAFETY OFF
  208.  
  209. m.in_area = SELECT()          && currently selected area
  210.  
  211. m.fstem = makealias(juststem(m.filname))
  212. IF USED(m.fstem)
  213.    SELECT (m.fstem)
  214. ELSE
  215.    SELECT 0
  216.    USE (m.filname)
  217. ENDIF
  218.  
  219.  
  220. FOR i = 1 TO FCOUNT()
  221.    fldname = FIELD(i)
  222.    IF !INLIST(TYPE(m.fldname),"M","G","P")
  223.       WAIT WINDOW "Indexing on "+m.fldname NOWAIT
  224.       INDEX ON &fldname TAG (m.fldname)
  225.    ENDIF
  226. ENDFOR
  227.  
  228. IF m.in_area <> SELECT()
  229.    USE
  230. ENDIF
  231. SELECT (m.in_area)
  232. IF m.comp_stat = "ON" OR m.comp_stat = "DB4"
  233.    SET COMPATIBLE TO DB4
  234. ENDIF
  235. IF m.safe_stat = "ON"
  236.    SET SAFETY ON
  237. ENDIF
  238. RETURN
  239.  
  240.  
  241. *!*****************************************************************
  242. *!
  243. *!      Procedure: OPENDBF
  244. *!
  245. *!*****************************************************************
  246. FUNCTION opendbf
  247. * Open a database and return the alias name, or an empty string
  248. *   if the database could not be opened.  Prompt user to find 
  249. *   database if necessary
  250. PARAMETERS fname
  251. PRIVATE stem
  252. IF FILE(m.fname)
  253.    m.stem = makealias(LEFT(juststem(m.fname),10))
  254.    IF USED(m.stem)
  255.       SELECT (m.stem)
  256.    ELSE
  257.       SELECT 0
  258.       m.fname = LOCFILE(m.fname,'DBF',;
  259.          'Please locate the '+juststem(m.fname)+' database')
  260.       IF EMPTY(m.fname)
  261.          RETURN ''
  262.       ELSE
  263.          USE (m.fname)
  264.       ENDIF
  265.    ENDIF
  266.    RETURN ALIAS()
  267. ELSE
  268.    RETURN ''
  269. ENDIF
  270.  
  271. *!*****************************************************************
  272. *!
  273. *!      Procedure: ACTWIN
  274. *!
  275. *!*****************************************************************
  276. FUNCTION actwin
  277. * Activate window wind_name
  278.  
  279. parameter wind_name
  280. PRIVATE ALL
  281. wind_name = UPPER(ALLTRIM(m.wind_name))
  282. IF !EMPTY(m.wind_name) AND WEXIST(m.wind_name)
  283.    ACTIVATE WINDOW (m.wind_name)
  284. ENDIF
  285. RETURN ''
  286.  
  287.  
  288. *!*****************************************************************
  289. *!
  290. *!      Procedure: ALERT
  291. *!
  292. *!*****************************************************************
  293. PROCEDURE alert
  294. * Display an error message, automatically sizing the message window
  295. *    as necessary.  Semicolons in "strg" mean "new line".
  296. PARAMETERS strg
  297. PRIVATE in_talk, in_cons, numlines, i, remain, maxlen, keycode
  298.  
  299. in_talk = SET('TALK')
  300. SET TALK OFF
  301. in_cons = SET('CONSOLE')
  302.  
  303. m.numlines = OCCURS(';',m.strg) + 1
  304.  
  305. DIMENSION alert_arry[m.numlines]
  306. m.remain = m.strg
  307. m.maxlen = 0
  308. FOR i = 1 TO m.numlines
  309.    IF AT(';',m.remain) > 0
  310.       alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1)
  311.       alert_arry[i] = CHRTRAN(alert_arry[i],';','')
  312.       m.remain = SUBSTR(m.remain,AT(';',m.remain)+1)
  313.    ELSE
  314.       alert_arry[i] = m.remain
  315.       m.remain = ''
  316.    ENDIF
  317.    IF LEN(alert_arry[i]) > SCOLS() - 6
  318.       alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6)
  319.    ENDIF
  320.    IF LEN(alert_arry[i]) > m.maxlen
  321.       m.maxlen = LEN(alert_arry[i])
  322.    ENDIF
  323. ENDFOR
  324.  
  325. m.top_row = INT( (SROWS() - 4 - m.numlines) / 2)
  326. m.bot_row = m.top_row + 3 + m.numlines
  327.  
  328. m.top_col = INT((SCOLS() - m.maxlen - 6) / 2)
  329. m.bot_col = m.top_col + m.maxlen + 6
  330.  
  331. DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col;
  332.    DOUBLE COLOR SCHEME 7
  333. ACTIVATE WINDOW alert
  334.  
  335. FOR i = 1 TO m.numlines
  336.    @ i,3 SAY PADC(alert_arry[i],m.maxlen)
  337. ENDFOR
  338.  
  339. SET CONSOLE OFF
  340. keycode = 0
  341. DO WHILE m.keycode = 0
  342.    keycode = INKEY(0,'HM')
  343. ENDDO
  344. SET CONSOLE ON
  345.  
  346. RELEASE WINDOW alert
  347.  
  348. IF m.in_talk = "ON"
  349.    SET TALK ON
  350. ENDIF
  351. IF m.in_cons = "OFF"
  352.    SET CONSOLE OFF
  353. ENDIF
  354.  
  355.  
  356. *!*****************************************************************
  357. *!
  358. *!      Procedure: APPERROR
  359. *!
  360. *!*****************************************************************
  361. PROCEDURE apperror
  362. * Simple ON ERROR routine for FoxApp application
  363.  
  364. PARAMETERS e_program,e_message,e_source,e_lineno,e_error
  365. CLEAR TYPEAHEAD
  366.  
  367. DO CASE
  368. CASE e_error = 217     && invalid display mode
  369.    SET CURSOR OFF
  370.    WAIT WINDOW "That display mode is not available on your computer."
  371.    SET CURSOR ON
  372.    RETURN
  373. CASE e_error = 1707    && CDX not found.  Ignore it.
  374.    RETURN
  375. OTHERWISE
  376.  
  377.    ON ERROR
  378.    m.e_source = ALLTRIM(m.e_source)
  379.    DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ;
  380.       +'Program: '+m.e_program +';' ;
  381.       +'  Error: '+m.e_message +';' ;
  382.       +' Source: '+IIF(LEN(m.e_source)<50,;
  383.       m.e_source,SUBSTR(m.e_source,1,50)+'...')
  384.    ON KEY
  385.    CLOSE ALL
  386.    CLEAR PROGRAM
  387.    CLEAR WINDOW
  388.    SET SYSMENU TO DEFAULT
  389.    IF FILE("foxapp.fky")
  390.       RESTORE MACROS FROM foxapp.fky
  391.       DELETE FILE foxapp.fky
  392.    ENDIF
  393.    * Restore original error routine if possible
  394.    IF TYPE('fxapp_error') = 'C'
  395.       ON ERROR &fxapp_error
  396.    ENDIF
  397.  
  398.    CANCEL
  399. ENDCASE
  400. RETURN
  401.  
  402. *!*****************************************************************
  403. *!
  404. *!      Procedure: SHOWPOP
  405. *!
  406. *!*****************************************************************
  407. PROCEDURE showpop
  408. * Determine if a popup can be displayed for this field
  409. PARAMETERS sourcedbf, varname
  410.  
  411. PRIVATE sourcedbf, targetdbf, varname, i, retval
  412.  
  413. * varname is in Proper case coming from BROWSE
  414. varname = UPPER(ALLTRIM(m.varname))
  415.  
  416. * See if any databases are keyed on varname
  417. m.targetdbf = 0
  418. FOR i = 1 TO m.numareas
  419.    IF SUBSTR(dbflist[i,m.cfldnum],AT('.',dbflist[i,m.cfldnum])+1);
  420.          == m.varname
  421.       m.targetdbf = i
  422.    ENDIF
  423. ENDFOR
  424.  
  425. * Make sure we can display list
  426. DO CASE
  427. CASE m.targetdbf = 0
  428.    WAIT WINDOW "No pick list is available for ";
  429.       +PROPER(m.varname)+'.' NOWAIT
  430.    retval = "NULL"
  431. CASE dbflist[m.targetdbf,m.cstemnum] = m.sourcedbf
  432.    * The target database is the one we are in!
  433.  
  434.    * Show the popup, but don't allow any replacements.
  435.    =disppop(dbflist[m.targetdbf,m.cdbfnum], m.varname)
  436.    retval = "NULL"
  437. OTHERWISE
  438.    retval = disppop(dbflist[m.targetdbf,m.cdbfnum], m.varname)
  439. ENDCASE
  440.  
  441. * Replace the selected value into the current field
  442. IF TYPE("retval") = "C"
  443.    IF retval <> "NULL"
  444.       REPLACE &varname WITH retval
  445.    ENDIF
  446. ELSE
  447.    REPLACE &varname WITH retval
  448. ENDIF
  449.  
  450. RETURN
  451. *!*****************************************************************
  452. *!
  453. *!      Procedure: DISPPOP
  454. *!
  455. *!*****************************************************************
  456. FUNCTION disppop
  457. * Display a scrollable list of items in the popdbf database
  458. PARAMETERS popdbf, varname
  459. PRIVATE ALL
  460.  
  461. * Store the value that varname has in the current database
  462. varnameval = &varname
  463.  
  464. in_area = SELECT()
  465. SELECT 0
  466. USE (popdbf) AGAIN
  467.  
  468. * Make sure it has a TAG of varname
  469. i = 1
  470. tag_found = .F.
  471. DO WHILE !EMPTY(TAG(i)) AND !tag_found
  472.    tag_found = (TAG(i) == varname)
  473.    IF !tag_found
  474.       i = i + 1
  475.    ENDIF
  476. ENDDO
  477. IF !tag_found
  478.    INDEX ON (varname) TAG (varname)
  479. ENDIF
  480. SET ORDER TO TAG (varname)
  481.  
  482. * Position picklist at the default value 
  483. SEEK varnameval
  484. IF !FOUND()
  485.    GOTO TOP
  486. ENDIF
  487.  
  488. * Figure out where the pick list should go
  489. DO CASE
  490. CASE COL() < scol()/2
  491.    s_col = scol()/2 + 1
  492.    e_col = scol() - 1
  493.    s_row = 5
  494.    e_row = SROWS() - 3
  495. CASE COL() >= scol()/2
  496.    s_col = 2
  497.    e_col = scol()/2 - 1
  498.    s_row = 5
  499.    e_row = SROWS() - 3
  500. ENDCASE
  501.  
  502. * Display pick list
  503. DEFINE WINDOW dbfwin FROM s_row, s_col TO e_row, e_col ;
  504.    TITLE PROPER(varname)+" pick list" ;
  505.    CLOSE GROW ZOOM FLOAT MINIMIZE ;
  506.    COLOR SCHEME 11
  507. *   COLOR W+/W,N/W,BG/N,BG/N,BG/N,N/BG,N/W,N+/N,BG/N,BG/N,+
  508.  
  509. ON KEY LABEL enter KEYBOARD CHR(23)
  510. SET SYSMENU OFF
  511. BROWSE WINDOW dbfwin NOEDIT NOAPPEND NODELETE
  512. SET SYSMENU AUTOMATIC
  513. ON KEY LABEL enter
  514.  
  515. * If user selected an item, return its value
  516. IF LASTKEY() <> 27
  517.    retval = &varname
  518. ELSE
  519.    retval = "NULL"
  520. ENDIF
  521.  
  522. * Do housekeeping and return
  523. RELEASE WINDOW dbfwin
  524. USE
  525. SELECT (in_area)
  526.  
  527. RETURN retval
  528. *!*****************************************************************************
  529. *!
  530. *!    Procedure: FNADDQUOTES
  531. *!
  532. *!*****************************************************************************
  533. FUNCTION fnaddquotes
  534. PARAMETER m.fname
  535.  
  536. DO CASE
  537. CASE INLIST(LEFT(m.fname,1), "'", '"', '[')
  538.    RETURN m.fname
  539. CASE AT('"', m.fname) = 0
  540.    RETURN '"' + m.fname + '"'
  541. CASE AT("'", m.fname) = 0
  542.    RETURN "'" + m.fname + "'"
  543. CASE AT("[", m.fname) = 0 AND AT("]", m.fname) = 0
  544.    RETURN "[" + m.fname + "]"
  545. OTHERWISE
  546.    RETURN m.fname      
  547. ENDCASE
  548.  
  549. *!*****************************************************************************
  550. *!
  551. *!    Procedure: MAKEALIAS
  552. *!
  553. *!*****************************************************************************
  554. FUNCTION makealias
  555. PARAMETER filname
  556. m.filname = UPPER(ALLTRIM(m.filname))
  557. m.filname = CHRTRAN(m.filname, ' ', '_')
  558. m.filname = LEFT(m.filname, 10)
  559. RETURN m.filname